perm filename S11D.F4[P11,LCS] blob
sn#341676 filedate 1978-03-11 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C ***** SCANNER FOR PDP11 VERSION *******
C00023 ENDMK
Cā;
C ***** SCANNER FOR PDP11 VERSION *******
C* SCANR,BGSORT,FMT,RANR,SQYY,COLTTY,READER,CLEAN,ACCEL,ERR,SHORT
SUBROUTINE SCANR
DIMENSION IP(30)
COMMON P(30),J,L,CNT(27),BT,PL(48),MK,DF,DUR(27)
1/E/IQ(27),ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,ISUB,NFLG,IXX,ISEMI,IQT
1 ,INP(144),VX(70),ISCA(12),IDAT(11),IAMP,K,KN,M,ML,CODE,IBLA
EQUIVALENCE(IF,ISCA(6)),(ISS,ISCA(9)),(IE,ISCA(5)),(IDOT,IDAT(11))
1 ,(IEN,ISCA(4)),(IP,PL)
C 2/74 IP IS NOW EQUIV TO PL! USED TO BE IP WITH P.(HURT 'TAP' ROUTINE.)
C WILL THIS DO ANYTHING TO MUSIC5 VERSION??
NNUM=-1
ISKP=0
JJ=0
XMINUS=1.
999 IDECI=-1
M=0
2799 N=INP(ML)
IF(N.NE.IQT)GO TO 899
JA=-1
ML=ML+1
ISUB=8
JJ=JJ+1
VX(JJ)=ML
C POINTS TO FIRST LIT. CHAR.
DO 1177 K=ML,144
IF(INP(K).NE.IQT)GO TO 1177
ML=K+1
2177 N=INP(ML)
GO TO 899
1177 CONTINUE
C SKIPS 'LIT' ITEMS IN RAN. SELECTION
899 ML=ML+1
IF(N.EQ.':')GO TO 751
IF(N.EQ.ISEMI)GO TO 751
IF(N.NE.IBLA)GO TO 510
4702 IF(ISKP)202,2799,2799
510 IF(JA)GO TO 70
DO 77 K=1,12
IF(N.NE.ISCA(K))GO TO 77
IF(K.EQ.2)GO TO 1511
IF(K.NE.4)GO TO 511
1511 NSWCH=K-4
GO TO 2177
C TO SWITCH ALWAYS USE OCT.# /PBF4/ /OE5/ P=PROXIMITY, O=ORDINARY
511 NNUM=K
JJ=JJ+1
NFLG=-1
N=INP(ML)
IF(N.NE.IF)GO TO 410
NNUM=NNUM-1
GO TO 610
410 IF(N.NE.ISS)GO TO 3410
NNUM=NNUM+1
610 ML=ML+1
N=INP(ML)
3410 IF(N.EQ.IEN)GO TO 3411
IF(N.NE.'I')GO TO 371
C 'END' OR 'FINE' WILL END INST.
3411 VX(JJ)=-10000.
IF(DUR(LK).LT.0)DUR(LK)=10000.
IAMP=-1
RETURN
371 IF(N.EQ.ISEMI)GO TO 5410
IF(N.EQ.IBLA)GO TO 5410
DO 177 KN=2,9
IF(N.NE.IDAT(KN))GO TO 177
IF(KN.EQ.9)CALL ERR(4)
C FOUND OCTAVE NUM.8 -- TOO HIGH!
JSCA=KN-2
ML=ML+1
GO TO 2410
177 CONTINUE
GO TO 6410
5410 KN=-1
6410 IF(NSWCH.EQ.0)GO TO 2410
IF(KN.LT.0)GO TO 7410
7410 IF(NOLD-NNUM.LE.5)GO TO 7411
IF(JSCA.LT.7)JSCA=JSCA+1
7411 IF(NOLD-NNUM.GE.-5)GO TO 2410
IF(JSCA.GT.0)JSCA=JSCA-1
C WILL JUMP TO NEAREST NOTE *********** MAY 22,71
2410 VX(JJ)=JSCA*12+NNUM
NOLD=NNUM
4410 NNUM=-2
IF(INP(ML).EQ.ISEMI)RETURN
C ABOVE FINDS SCALE NOTES; IF NSWCH=0 OCT. NUM WILL STICK UNTIL RESET
IF(N.EQ.IXX)GO TO 210
IF(N.EQ.'*')GO TO 210
GO TO 310
77 CONTINUE
70 IF(N.NE.'-')GO TO 71
XMINUS=-1.
GO TO 2799
210 JJ=JJ+1
IF(JJ.EQ.1)GO TO 3310
XMINUS=1.
VX(JJ)=0
C 'X N1,N2' MAY REPLACE 'REP N1,N2'. N2=0 BECOMES N2=2
GO TO 310
71 IF(N.EQ.IXX)GO TO 210
IF(N.EQ.'*')GO TO 210
IF(N.EQ.'R')GO TO 73
1410 DO 78 K=1,11
IF(N.NE.IDAT(K))GO TO 78
ISKP=-1
IF(N.NE.IDOT)GO TO 79
IDECI=M
GO TO 75
79 M=M+1
IP(M)=K-1
GO TO 75
78 CONTINUE
IF(N.NE.IE)GO TO 8811
IF(INP(ML).NE.IEN)GO TO 781
GO TO 7811
8811 IF(N.NE.IF)GO TO 781
IF(INP(ML).NE.'I')GO TO 781
C 'EN(D)' OR 'FI(NE)' WILL END INST.
7811 JJ=1
GO TO 3411
781 IF(N.EQ.'/')N=ISEMI
C FOR MOTIVIC TRANFORMATIONS
75 KN=INP(ML)
275 IF(KN.NE.IXX)GO TO 175
IF(M.NE.0)GO TO 202
175 IF(KN.EQ.'*')GO TO 202
C FOR 2X3, 2*3, ETC. CHECK THIS OUT. 6/74
IF(N.EQ.ISEMI)GO TO 751
IF(KN.NE.1)GO TO 2799
C WHEN IS INP(ML) (I.E. KN) SET TO 1?????
751 IF(ISKP.EQ.0)RETURN
202 IF(IDECI.NE.-1)GO TO 302
IDECI=0
GO TO 402
302 IDECI=M-IDECI
402 KN=0
IEXP=M-1
IF(M.LT.1)M=1
DO 171 K=1,M
KV=10**IEXP
IF(IEXP.EQ.0)KV=1
KN=KN+IP(K)*KV
171 IEXP=IEXP-1
A=10**IDECI
IF(IDECI.EQ.0)A=1.
JJ=JJ+1
VX(JJ)=KN/A*XMINUS
IF(ISUB.EQ.1)RETURN
IF(CODE.NE.-22.)XMINUS=1.
C ONLY ONE - NEEDED FOR RHY.COMPOSITE
1310 IF(INP(ML).NE.1)GO TO 310
VX(JJ+1)=VX(JJ)*2.
JJ=JJ+1
ML=ML+1
GO TO 1310
206 ML=ML+2
3310 VX(1)=-99.
310 ISKP=0
IF(N.NE.ISEMI)GO TO 999
RETURN
73 JJ=JJ+1
IF(INP(ML).EQ.IE)GO TO 206
C NEXT IS FOR A REST ('R')
VX(JJ)=85.
731 N=INP(ML)
IF(N.EQ.'/')RETURN
IF(N.EQ.ISEMI)RETURN
IF(N.NE.IBLA)GO TO 899
ML=ML+1
GO TO 731
END
SUBROUTINE BGSORT(BW)
C THIS SORTS BG TIMES SO NONE ARE DUPLICATED IN BNW ARRAY.
C ALLOWS 100 BG TIMES.
COMMON /Q/ BNW(100),NWZ
DO 5308 K=1,NWZ
X=BNW(K)-.0001
Y=X+.0002
C ROUND-OFF NONSENSE
IF(BW.LE.X)GO TO 5308
IF(BW.LT.Y)RETURN
5308 CONTINUE
NWZ=NWZ+1
BNW(NWZ)=BW
RETURN
END
CCC SUBROUTINE FMT(JFM,INP,MLX)
CCC DIMENSION JFM(3),INP(1)
CCC DO 1 MLX=2,72
CCC J=INP(MLX)
CCC IF(J.EQ.' ')J=' '
C ABOVE FINDS A TAB, CHANGES IT TO BLANK SPACE
CCC IF(J.EQ.' ')GO TO 2
CCC IF(J.EQ.',')GO TO 2
CCC IF(J.EQ.';')GO TO 2
CCC1 CONTINUE
C*** TEMPORARY CHANGE ***** IF(J.EQ.':')GO TO 3
CCCC SPACE=COMMA=SPACE, ALSO STOPS ON ";"
CCC3 CALL ERR(1)
C ERROR IF COLON IS FOUND OR THERE IS NO END MARK
CCC2 MLX=MLX+1
CCC IF(MLX.GT.7)MLX=7
CCC JFM(2)='0'+(MLX-2)*536870912
C FINDS NUMBER FOR 'A' FORMAT
CCC END
SUBROUTINE RANR(VX,K)
C FOR RAN. SELEC. OF NOTES. FINDS HIGHEST NOTE.
DIMENSION VX(1)
X=VX(K)
Y=VX(K+1)
IF(X.GT.Y)VX(K)=X+.999
IF(Y.GE.X)VX(K+1)=Y+.999
RETURN
END
SUBROUTINE SQYY(YY,X,Y,Z)
YY=2.*Z/(X+Y)
IF(YY.NE.0)YY=2.*(Z-X*YY)/YY**2
RETURN
END
C****** THIS ROUTINE PROBABLY MUST BE CHANGED FOR PDP11 **********
SUBROUTINE COLTTY(JNP,JT)
COMMON /TYP/SOS,JOUT,LN,ITYP,TPALN(4),JED
DIMENSION JNP(1)
DO 1 K=72,1,-1
JJ=JNP(K)
1 IF(JJ.NE.' '.AND.JJ.NE.' ')GO TO 2
C SECOND SPACE IS A TAB.
K=1
2 TYPE 10,(JNP(L),L=1,K)
10 FORMAT(1X,72A1)
CCC2 IF(JT.EQ.21)GO TO 3
CCC J(1)=' (1X'
C*** IF(LN.EQ.0)GO TO 5
C*** J(1)='(I6,X'
C*** WRITE(JT,J)LN,(JNP(L),L=1,K)
C*** RETURN
CCC3 J(1)=' ('
CCC5 WRITE(JT,J)(JNP(L),L=1,K)
END
C****** THIS ROUTINE PROBABLY MUST BE CHANGED FOR PDP11 **********
FUNCTION READER(JNP)
DIMENSION JNP(72)
COMMON /TYP/SOS,JOUT,LN,ITYP,TPALN(4),JED
DATA TPALN/20H(' TYPE A LINE'/) /
C**** J(1)=' ('
10 FORMAT(72A1)
READER=0
IF(ITYP.LT.0)GO TO 1
C ITYP=0=DIRECT TYPEIN MODE
6 TYPE TPALN
ACCEPT 10,JNP
CCC ACCEPT J,JNP
IF(JED.LT.0)CALL COLTTY(JNP,21)
GO TO 8
C********1 IF(IFI.LT.0)GO TO 5
1 READ(23,10,END=3)JNP
LN=LN+1
GO TO 7
3 READER=-1
GO TO 8
C****5 J(1)=' (I,'
C**** READ(23,J,END=3)LN,JNP
C****7 IF(SOS.LT.0)CALL COLTTY(JNP,5)
7 CALL COLTTY(JNP,5)
8 IF(JNP(1).EQ.' ')JNP(1)=' '
C CHANGES TAB TO SPACE ABOVE.
END
SUBROUTINE CLEAN(INP,LEND)
DIMENSION INP(1)
C CLEAR THE END OF ARRAY
M=72
LEND=-1
K=0
1 K=K+1
NN=INP(K)
IF(NN.EQ.';')GO TO 2
IF(NN.EQ.'/')GO TO 2
IF(NN.EQ.'<')GO TO 3
C USE < FOR COMMENT-- AS IN MUS10
IF(NN.EQ.','.OR.NN.EQ.' ')INP(K)=' '
CHANGE ALL COMMAS AND TABS TO BLANKS(IT LOOKS LIKE A BLANK ABOVE, BUT ISN'T)
C**** FOR CHORD FEATURE IF(NN.EQ.':')CALL ERR(1)
IF(NN.NE.'"')GO TO 4
7 K=K+1
IF(INP(K).EQ.'"')GO TO 4
IF(K.LT.M)GO TO 7
CALL ERR(5)
2 LEND=K
4 IF(K.LT.M)GO TO 1
3 IF(LEND.GT.0)RETURN
IF(M.EQ.144)CALL ERR(2)
CALL READER(INP(73))
C GO READ ANOTHER LINE.
M=144
K=72
GO TO 1
END
SUBROUTINE ERR(K)
GO TO(1,2,3,4,5)K
TYPE 199,K
199 FORMAT(' ERROR!! LAST LINE READ =',I6)
CALL EXIT
1 TYPE 11
CALL EXIT
11 FORMAT(' ILLEGAL COLON')
2 TYPE 12
CALL EXIT
12 FORMAT(' NO END MARK')
3 TYPE 13
CALL EXIT
13 FORMAT(' MORE THAN 2 PARENS OPEN')
4 TYPE 14
CALL EXIT
14 FORMAT(' SOME NUMBER OUT OF BOUNDS')
5 TYPE 15
CALL EXIT
15 FORMAT(' OPEN QUOTES')
END
SUBROUTINE ACCEL
COMMON/VV/LIMIT,V(1)/A/ROFF(27),NP(27),PCH(27,32),
1 RDEV(27),IPT(27,31),XT(27),OTH(20,16)
1 ,P1(27),COPY(30),IFM(80)
1 ,INVIS(27)
COMMON P(30),J,L,CNT(27),BT,PL(48),MK,DF,DUR(27)
1/E/IQ(27),KL,X,ZPAR,KA,LK,NNUM,JJ,JA,ISUB,NFLG,IXX,ISEMI,IQT
1 ,INP(144),VX(70),ISCA(12),IDAT(11),IAMP,K,KN,M,ML,CODE,IBLA
COMMON/B/MOT,PR,T5,NINS,I,TP,RA,KZY,NWX,INONLY,MX,
1 Y,Z,ISLAC,MZ,N,IDALL,JC,JG,RB,IJ,IX,BW,KB,NL,RC,W,
1 ZZ,CHN,YY
1 /C/LPAR,IPRN,QX,IRTRO,INVRT,ICON,LCNT,
1 IPAREN,JZ,BY,MLX,IZ,ALL,JD,LEND,QTS,ITMP,
1 LP,ILIT,NLIT,KTMP,IC,NONO,RD,IA
C /C/=26
IF(T5.EQ.1)GO TO 4020
XA=RA
7020 RA=V(IA+K)
IF(RA.EQ.-10000.)RETURN
4020 RD=1
IF(RA.LT.0)RD=-1.
RA=RA*RD
IF(KA.EQ.0)RA=RA-RC
W=RA
RB=W
IF(W.LE.Z-.0001)GO TO 2020
C .0001 FOR ROUND-OFF ERRORS!!!!!!!
IF(Z.NE.0)GO TO 3020
RA=RA/Y
RB=-1.
RC=0
GO TO 8020
3020 W=Z
RC=W+RC
GO TO 24
2020 RC=0
24 IF(X.NE.Y)GO TO 424
RA=W/X
GO TO 8020
C DUR OF TMP + BG TIME OF TMP - NOTE VALUE -
C BG TIME OF NOTE. CHN=TBG.
424 RAX=XT(J)
RA=(-2.*RAX+(4.*RAX**2+8.*YY*W)**.5)/(2.*YY)
C THIS DOES THE WORK ACCELS.
XT(J)=RAX+YY*RA
8020 IF(KA.EQ.0)RA=RA+XA
KA=1
IF(T5.NE.1)GO TO 1012
IF(RC.NE.0)GO TO 2011
RETURN
C T5=1 IN 'RUNIT'
1012 V(IA+K)=RA*RD
IF(K.EQ.IZ)RETURN
1011 IF(T5.EQ.1)GO TO 2011
K=K+1
IF(ZZ.NE.0)Z=Z-W
IF(Z.GT.0)GO TO 7020
IF(RB.EQ.-1.)GO TO 7020
IC=IC+1
IF(RB.EQ.W)RETURN
KA=0
K=K-1
RETURN
2011 XA=RA
IF(K.GT.1)GO TO 9020
K=I-6
ZPAR=-9900.-CHN-ZZ
DO 3011 KL=8,I
IF(V(K).NE.ZPAR)GO TO 3011
IF(V(K+1).EQ.990000.)GO TO 9020
3011 K=K-1
9020 W=ZZ
IF(V(K+3))K=K+3
C ABOVE IS FOR TYPED IN TEMPO CHANGES
KA=K+3
ZZ=V(KA)
C DUR OF NEXT TEMPI
X=V(KA+1)
Y=V(KA+2)
213 KA=0
Z=ZZ
CALL SQYY(YY,X,Y,Z)
CHN=CHN+W
XT(J)=X
IF(KA.EQ.1)Z=0
RA=PR
KA=0
K=K+3
GO TO 4020
END
SUBROUTINE SHORT(KNP,K)
C DON'T TYPE TRAILING BLANKS
DIMENSION KNP(1)
DO 1 K=72,1,-1
1 IF(KNP(K).NE.' ')RETURN
K=1
END
C THIS ROUTINE ALLOWS NAMES OF FROM 1 TO 5 LETTERS TO BE USED.
C NO EXTENSIONS CAN BE USED. INF RETURNS INFO REL LINE NUMS.
CC SUBROUTINE IFILE(I,N,INF)
CC EQUIVALENCE (NN,NAME),(NN2,NN(2))
CC COMMON /NN/NN(2)
CC DOUBLE PRECISION NAME
CC DATA NN(2)/'.'/
CC5 INF=0
CC NN(1)=N
CC OPEN(UNIT=I,FILE=NAME)
CC IF(NN2.NE.'.')GO TO 1
C JUMP IF COMING FROM OFILE CALL
CC READ(I,2)K,J
CC IF(K.NE.'00')GO TO 3
CC INF=-1
C INF = -1 = LINE NUMBERS.
CC6 OPEN(UNIT=I,FILE=NAME)
C REOPEN IF LINE NUMS OR NO "COMMENT"
CC GO TO 1
CC3 IF(K.NE.'CO')GO TO 6
CC IF(J.NE.'MMENT')GO TO 6
CC4 READ(I,2)K,J
C READS COMMENTS ON DIRECTORY PAGE.
CC IF(J.NE.';')GO TO 4
CC2 FORMAT(A2,A5)
CC1 NN2='.'
CC END
CC SUBROUTINE OFILE(I,N,IEXT)
CC COMMON /NN/NN1,NN2
CC NN2=IEXT
CC CALL IFILE(I,N,INF)
CC END